home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / manchest.lha / MANCHESTER / manchester / 4.1 / mouseEvents.st < prev    next >
Text File  |  1993-07-24  |  7KB  |  240 lines
  1. "    NAME        mouseEvents
  2.     AUTHOR        Bernard Horan <bernard@is.morgan.com>
  3.     CONTRIBUTOR    Bernard Horan <bernard@is.morgan.com>
  4.     FUNCTION      experimentation with pseudo-event driven mouse events
  5.     ST-VERSIONS    4.1
  6.     PREREQUISITES     
  7.     CONFLICTS     
  8.     DISTRIBUTION    world
  9.     VERSION        1.0
  10.     DATE        October 1992
  11.     SUMMARY        This file contains the results of some experimentation with mouse events. Specifically, simulating events from the polling loop. To do so, it introduces a few new classes, and comes with examples. Not meant to real use, but gives an indication of where to start hacking :~). BH, 7/5/93"!
  12.  
  13. PluggableAdaptor subclass: #MultiPluggableAdaptor
  14.     instanceVariableNames: 'putBlocks '
  15.     classVariableNames: ''
  16.     poolDictionaries: ''
  17.     category: 'mouse events'!
  18.  
  19.  
  20. !MultiPluggableAdaptor methodsFor: 'initialize-release'!
  21.  
  22. initialize
  23.     super initialize.
  24.     putBlocks := Dictionary new.
  25.     self overridePutBlock! !
  26.  
  27. !MultiPluggableAdaptor methodsFor: 'initialize algorithm'!
  28.  
  29. collectionIndex: index
  30.     " Initialize the receiver to access
  31.     the given element of a collection
  32.     that is the value of the model. "
  33.  
  34.     super collectionIndex: index.
  35.     self overridePutBlock!
  36.  
  37. getSelector: aSymbol0 putSelector: aSymbol1
  38.     " Initialize the receiver to act like
  39.     the old pluggable classes. "
  40.  
  41.     super getSelector: aSymbol0 putSelector: aSymbol1.
  42.     self overridePutBlock.!
  43.  
  44. selectValue: aValue
  45.     super selectValue: aValue.
  46.     self overridePutBlock! !
  47.  
  48. !MultiPluggableAdaptor methodsFor: 'accessing'!
  49.  
  50. send: aSymbol with: anArgument
  51.     | block |
  52.     block := self putBlockAt: aSymbol.
  53.     block value: model value: anArgument!
  54.  
  55. setValue: newValue
  56.     | block |
  57.     block := self putBlockAt: #default.
  58.     block value: model value: newValue! !
  59.  
  60. !MultiPluggableAdaptor methodsFor: 'private'!
  61.  
  62. at: aSymbol putBlock: aBlock
  63.     putBlocks at: aSymbol put: aBlock!
  64.  
  65. overridePutBlock
  66.     putBlock := [:m :v | "do nothing"].
  67.     self at: #default putBlock: putBlock!
  68.  
  69. putBlockAt: aSymbol
  70.     ^self putBlockAt: aSymbol ifAbsent: [self putBlockAt: #default]!
  71.  
  72. putBlockAt: aSymbol ifAbsent: aBlock
  73.     ^putBlocks at: aSymbol ifAbsent: aBlock! !
  74.  
  75. WidgetController subclass: #EventController
  76.     instanceVariableNames: ''
  77.     classVariableNames: 'DoubleClickTime StillDownTime '
  78.     poolDictionaries: ''
  79.     category: 'mouse events'!
  80. EventController comment:
  81. 'I am a specialisation of WidgetController. I pretend to be event-driven. The events I send
  82. are:
  83. #enter
  84. #leave
  85. #wentDown
  86. #wentUp
  87. #click
  88. #doubleClick
  89. #stillDown
  90.  
  91. To get them sent to a model (such as a MultiPluggableAdaptor -- see this class category) initialize me using the <beMultiple> message.  It''s possibly inadvisable to use me with an
  92. ordinary PluggableAdaptor since I assume that its block arguments are the <sensor> and the
  93. <event> (instead of the <point> and the <event>); although the standard initialization alogrithms that
  94. are available in class PluggableAdaptor never use the <point>.
  95.  
  96. The main method I override is controlLoopBody. Another important method is isControlActive, I no
  97. longer give up control if the red buttonis pressed.
  98.  
  99. Class Variables:
  100. DoubleClickTime (400).
  101. StillDownTime (100).
  102. Used as a test to detemine when to recognise a double click or a stillDown.
  103.  
  104. Try the example. On some machines, you may have to change the double click time because of the
  105. time it takes to write to the Transcript, otherwise take out the bit that writes to the Transcript.
  106.  
  107.  
  108. Enjoy,
  109.  
  110. Bern'!
  111.  
  112.  
  113. !EventController methodsFor: 'initialize-release'!
  114.  
  115. beMultiple
  116.     controlBlock := [:sen :button | model send: button with: sen]! !
  117.  
  118. !EventController methodsFor: 'control'!
  119.  
  120. controlInitialize
  121.     controlBlock value: self sensor value: #enter!
  122.  
  123. controlLoopBody
  124.     "Pretend to send events.
  125.     Bernard Horan - 11 June 1992"
  126.     | state downTime hasClick |
  127.     hasClick := false.
  128.     state := self sensor redButtonPressed
  129.                 ifTrue: [#wentDown]
  130.                 ifFalse: [#wentUp].
  131.     state = #wentDown
  132.         ifTrue: 
  133.             [downTime := Time millisecondClockValue.
  134.             controlBlock value: self sensor value: #wentDown].
  135.     [self isControlActive]
  136.         whileTrue: 
  137.             [| previousState clickTime |
  138.             previousState := state.
  139.             self poll.
  140.             state := self sensor redButtonPressed
  141.                         ifTrue: [#down]
  142.                         ifFalse: [#up].
  143.             (state = #up and: [previousState = #wentDown or:[previousState = #stillDown]])
  144.                 ifTrue: [state := #wentUp.
  145.                     controlBlock value: self sensor value: #wentUp].
  146.             (previousState = #wentDown and: [state = #down])
  147.                 ifTrue: [state := #wentDown.
  148.                     Time millisecondClockValue - downTime > StillDownTime ifTrue: [controlBlock value: self sensor value: #stillDown]].
  149.             (hasClick and: [state = #wentUp])
  150.                 ifTrue: [clickTime isNil ifFalse: [Time millisecondClockValue - clickTime < DoubleClickTime ifTrue: [controlBlock value: self sensor value: #doubleClick]]].
  151.             (previousState = #wentDown and: [state = #wentUp])
  152.                 ifTrue: 
  153.                     [hasClick := true.
  154.                     clickTime := Time millisecondClockValue.
  155.                     controlBlock value: self sensor value: #click].
  156.             (state = #down and: [previousState = #wentUp])
  157.                 ifTrue: 
  158.                     [downTime := Time millisecondClockValue.
  159.                     controlBlock value: self sensor value: #wentDown].
  160.             state = #down ifTrue:[state := #wentDown].
  161.             state = #up ifTrue:[state := #wentUp]]!
  162.  
  163. controlTerminate
  164.     "send the #leave event.
  165.     Bernard Horan - 11 June 1992"
  166.     controlBlock value: self sensor value: #leave!
  167.  
  168. isControlActive
  169.     ^self viewHasCursor | self sensor redButtonPressed! !
  170. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  171.  
  172. EventController class
  173.     instanceVariableNames: ''!
  174.  
  175.  
  176. !EventController class methodsFor: 'class initialization'!
  177.  
  178. initialize
  179.     "EventController initialize"
  180.     DoubleClickTime := 400.
  181.     StillDownTime := 100.! !
  182.  
  183. !EventController class methodsFor: 'examples'!
  184.  
  185. example
  186.     "EventController example"
  187.  
  188.     | window view adaptor |
  189.     window := ScheduledWindow new.
  190.     window label: 'fred'.
  191.     adaptor := MultiPluggableAdaptor on: ValueHolder newBoolean.
  192.     view := LabeledBooleanView model: adaptor.
  193.     view controller: EventController new.
  194.     view controller beMultiple.
  195.     view label: 'fred'.
  196.     adaptor at: #default putBlock: [:m :v | "Transcript show: v printString; cr"].
  197.     adaptor at: #enter putBlock: [:m :v | m value: true].
  198.     adaptor at: #leave putBlock: [:m :v | m value: false].
  199.     adaptor at: #doubleClick putBlock: [:m :v | 
  200.             "toggle"m value: m value not].
  201.     adaptor at: #stillDown putBlock: [:m :v | v cursorPoint x > view bounds right ifTrue: [
  202.                 "If the user drags to the right, drag the view's label until a mouse 
  203.             button is released"Screen default
  204.                 dragShape: view label asComposedText
  205.                 offset: 0 @ 0
  206.                 gridPhase: 0 @ 0
  207.                 gridSpacing: 1 @ 1
  208.                 boundedBy: nil
  209.                 whileButton: 0
  210.                 isDown: true]].
  211.     window component: (BorderedWrapper on: view).
  212.     window open!
  213.  
  214. example2
  215.     "EventController example2"
  216.  
  217.     | window view adaptor |
  218.     window := ScheduledWindow new.
  219.     window label: 'fred'.
  220.     adaptor := MultiPluggableAdaptor on: ValueHolder newBoolean.
  221.     view := LabeledBooleanView model: adaptor.
  222.     view controller: EventController new.
  223.     view controller beMultiple.
  224.     view label: 'fred'.
  225.     adaptor at: #stillDown putBlock: [:m :v | v cursorPoint x > view bounds right ifTrue: [
  226.                 "If the user drags to the right, drag the view's label until a mouse 
  227.             button is released"Screen default
  228.                 dragShape: view label asComposedText
  229.                 offset: 0 @ 0
  230.                 gridPhase: 0 @ 0
  231.                 gridSpacing: 1 @ 1
  232.                 boundedBy: nil
  233.                 whileButton: 0
  234.                 isDown: true]].
  235.     window component: (BorderedWrapper on: view).
  236.     window open! !
  237. EventController initialize!
  238.  
  239.  
  240.